home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 014a / clrlaser.zip / LASER.PAS < prev   
Pascal/Delphi Source File  |  1991-03-03  |  6KB  |  244 lines
  1. PROGRAM  LASER;{ colourful display on VGA.. March 1991}
  2. {$R-}
  3. {$I-}
  4. uses dos,crt,gcolor,graph,drivers, fonts;
  5.  
  6. const
  7.     c1          = 150; {75;}
  8.     c2          =  18; {9; }
  9.     c3          =   6; {3; }
  10.     maxindex    = 150;
  11.     ymin        =   0;
  12.     ymax        = 479;
  13.     xmin        =   0;
  14.     xmax        = 639;
  15.     maxcolor    =  15;
  16.     space       = ' ';
  17.     red         =   8;
  18.     blue        =   7;
  19.     green       =   2;
  20.    TYPE
  21.     irange      = 0..maxindex;
  22.     screencolor = 0..maxcolor;
  23.  
  24.     linerec     = RECORD
  25.                      x1, x2: integer;
  26.                      y1, y2 : integer;
  27.                      color :screencolor;
  28.                   END; { record}
  29. VAR
  30.     color   : screencolor;
  31.     erasing : boolean;
  32.     x1, x2  : integer;
  33.     y1, y2  : integer;
  34.     index   : irange;
  35.     current_color : screencolor;
  36.     laser_is_4 : boolean ; { laser_is_4 if true, else only one}
  37.     laser_is_2 : boolean ; { laser_is_2 if true, else only one}
  38.     temp,count1,count2, dx1, dx2, dy1, dy2,x,y : integer;
  39.     linearray  : ARRAY [ irange ] OF linerec;
  40.     f     : text;
  41.     ch    : char;
  42.  
  43.     graphdriver, graphmode, errorcode: integer;
  44.     w,c,n : integer;
  45.  
  46.  
  47. PROCEDURE ginit; { INITIALIZE vga 640X480 GRAPHICS}
  48. begin
  49.  graphdriver := detect;
  50. InitGraph(graphdriver,graphmode, '');
  51.  Errorcode:=graphresult;
  52.  
  53. if errorcode <>grOK then
  54.   begin
  55.    writeln ('graphics error', GrapherrorMsg(errorcode));
  56.    writeln('program aborting..');
  57.    halt (1);
  58.   end;
  59. end;
  60.  
  61.  
  62.  
  63. PROCEDURE startup; { welcome user, general setup}
  64. var p,l : integer;
  65.        procedure WSTRING (S:STRING; A,B : INTEGER);
  66.        BEGIN
  67.         TextColor(B);
  68.         GoToXY(p,l);
  69.         Write(s);
  70.        END;{wstring}
  71. BEGIN
  72.    p := 40;
  73.    Setcolor (red); rectangle (p,p,xmax-p,ymax-p);
  74.    p := 45;
  75.    Setcolor (blue); rectangle (p,p,xmax-p,ymax-p);
  76.    p := 50;
  77.    Setcolor (green); rectangle (p,p,xmax-p,ymax-p);
  78.  
  79.    p := 10; l := 5;
  80.    GoToXY (p,l);
  81.    wstring ('Welcome to',0,2);
  82.    p := 20; l := 6;
  83.    wstring('   *** Lasergraph ***',0,5);
  84.    p := 10; l:=10;
  85.    wstring ('<ESC> will terminate',0,7);
  86.    l:= 12;
  87.    wstring ('<SPACE> will freeze and',0,9);
  88.    l := 14;
  89.    wstring ('restart the display',0,9);
  90.    l := 18;
  91.    wstring ('tell me the number of lasers',0,11);
  92.    l := 20;
  93.    wstring (' Press <1> <2> or <4>',0,11);
  94.  
  95.       ch := '0'; laser_is_4 := false; laser_is_2 := false;
  96.          repeat
  97.             ch :=  readkey;
  98.          until ch in [ '1','2','4'];
  99.  
  100.       if ch = '2' then laser_is_2 := true;
  101.       if ch = '4' then laser_is_4 := true;
  102.       if ch = '4' then laser_is_2 := true;
  103.  
  104.    GoToXY (16,182);
  105.  
  106. end; { startup}
  107.  
  108. PROCEDURE initialize;
  109. begin
  110.    x1     := xmin; x2     := xmin;
  111.    y1     := ymin; y2     := ymin;
  112.    color  := 0;
  113.    index  := 0;
  114.    count1 := 0;
  115.    count2 := 0;
  116.    ch     := chr(0);
  117.    erasing := false;
  118.    randomize;
  119.  
  120. END; { initialize}
  121.  
  122.  
  123. PROCEDURE newstep; { return new dx, dy .. delta }
  124. BEGIN
  125.    dx1  :=   random (c2 - c3);
  126.    dx2  :=   random (c2 - c3);
  127.    dy1  :=   random (c2 - c3);
  128.    dy2  :=   random (c2 - c3);
  129.    count2:=  random (c1 - 1);
  130. END; { newstep}
  131.  
  132. PROCEDURE eraseline (lline:linerec);
  133. BEGIN
  134.      WITH LLINE DO
  135.        BEGIN
  136.            Setcolor (0);
  137.        line(x1,y1,x2,y2); { black out the line in color 0 (bkgnd) }
  138.          if laser_is_2 THEN
  139.            line(xmax-x1,ymax-y1,xmax-x2,ymax-y2);
  140.          if laser_is_4 then
  141.           BEGIN
  142.            line(xmax-x1,y1,xmax-x2,y2);
  143.            line(x1,ymax-y1,x2,ymax-y2);
  144.           END;
  145.        END;
  146.  
  147. END; { eraseline}
  148.  
  149. PROCEDURE computenew{(var x1,x2:xrange ; y1,y2:yrange )};
  150.  { calc new x and y }
  151.    PROCEDURE newcoord (var n,change: integer; min,max : integer);
  152.        { calc new co-ord n; of change; within min, max }
  153.  
  154.    VAR
  155.       temp: integer;
  156.    BEGIN
  157.       temp := n + change;
  158.       IF ( temp < min ) OR ( temp > max)
  159.           THEN change := - change
  160.           ELSE n := temp
  161.    END;  { newcoord}
  162.  
  163. BEGIN  { computenew }
  164.    newcoord ( x1, dx1, xmin, xmax );
  165.    newcoord ( y1, dy1, ymin, ymax );
  166.    newcoord ( x2, dx2, xmin, xmax );
  167.    newcoord ( y2, dy2, ymin, ymax )
  168. END;  { computenew}
  169.  
  170. PROCEDURE  storedata ( xx1,xx2:integer; yy1,yy2:integer;
  171.                        current_color : screencolor; index :irange ) ;
  172.                        { save line in array at index }
  173. BEGIN
  174.    WITH linearray [ index ]  DO
  175.       BEGIN
  176.           x1 := xx1; x2 := xx2;
  177.           y1 := yy1; y2 := yy2;
  178.           color := current_color;
  179.       END; { with }
  180. END ; {  storedata}
  181.  
  182. BEGIN    {main}
  183.  
  184.  
  185.     ginit;
  186.  
  187.     startup;
  188.  
  189.     initialize ;
  190.  
  191.      ClearViewport;
  192.  
  193.      current_color := maxcolor;
  194.  REPEAT { until <esc> }
  195.       IF index = maxindex
  196.           THEN
  197.              BEGIN
  198.                 index := 1; erasing := true
  199.              END
  200.           ELSE
  201.              index := index + 1;
  202.  
  203.           IF erasing
  204.              then eraseline (linearray [ index] );
  205.  
  206.           IF  count1 = 0
  207.              THEN { return new color and count1}
  208.               BEGIN
  209.                  current_color := random (maxcolor - 1) + 1 ;
  210.                  count1 := random ( c1) + 1;
  211.               END; { newcolor}
  212.  
  213.           IF  count2 = 0
  214.              THEN newstep { returning dx1,dy1,dx2,dy2,
  215.                              and new random count2}   ;
  216.  
  217.           count1 := count1 -1;
  218.           count2 := count2 -1;
  219.           computenew{(x1, x2, y1, y2 )};
  220.  
  221.            storedata ( { saving} x1,x2,y1,y2, current_color,
  222.                        { in array using }  index     );
  223.  
  224.                SetColor(current_color);
  225.            line(x1,y1,x2,y2);
  226.           IF laser_is_2 then
  227.                line(xmax-x1,ymax-y1,xmax-x2,ymax-y2);
  228.            IF laser_is_4 then
  229.              BEGIN
  230.                line(xmax-x1,y1,xmax-x2,y2);
  231.                line(x1,ymax-y1,x2,ymax-y2);
  232.              END;
  233.  
  234.           IF  keypressed  THEN
  235.              BEGIN
  236.                 repeat
  237.          ch := readkey;
  238.                  UNTIL(ch =space)or(ch =chr(27));
  239.                    END;
  240.  
  241.  
  242.  UNTIL  ch = chr(27);
  243.    CloseGraph;
  244.  END.